Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops ƒ / Modules < prev next >

Wrap

Text File | 1995-11-22 | 13.9 KB | 566 lines | [TEXT/MSET]

\ This file implements relocatable modules. In installed applications, \ these become separate code segments. true value CLEANMOD? false value RELEASED? 0 value THIS_MOD 0 value LAST_MOD 0 value svDP 0 value evSvDP 0 value svLatest 0 value evSvLatest 0 value modstart string $EXP string $CXT string $evCXT \ variable SAVE_CONTEXT 8 4 * allot : UNEVAL \ Puts things back to normal after an EVAL" evSvDP 0EXIT \ Out if we're not compiling an eval" evSvLatest -> latest evSvDP -> DP 0 -> evSvDP nil?: $evCxt NIF ptr: $evCxt context 32 cmove release: $evCxt THEN ; : UNMOD \ Puts things back to normal after a module \ or stand-alone code compilation or eval" unEval svDP 0EXIT \ Out if we're not compiling a module/SA svLatest -> latest svDP -> DP 0 -> svDP 0 -> compMod nil?: $cxt NIF ptr: $cxt context 32 cmove release: $cxt THEN false -> SAcomp? ; : >NXTEXP \ ( n -- ) modstart - pad ! pad 4 add: $exp ; :class MODULE super{ object } record { handle MODHDL byte EXEC_CNT \ Must be at an even offset since we sometimes bool LOCKED? \ do a combined access to exec_cnt and locked? ! byte FLAGS int RES# int #IMP dicaddr LASTIMP dicaddr LOADPOINT var DicDateTime int RELOFFS int INSTALL? } :m BASE: nil?: modHdl IF 0 EXIT THEN nptr: modHdl ;m :m HANDLE: get: modHdl ;m :m .ID: ^base obj> .id ;m :m SETRELEASE: \ ( addr -- ) modbase - put: relOffs ;m :m SETRESID: \ ( resID -- ) put: res# ;m :m INSTALL?: get: install? ;m :m SETINSTALL: put: install? ;m \ KLUDGE: and UNKLUDGE: may be used when we save a dic image, to mark \ a module as unloaded in the saved image without really unloading it. :m KLUDGE: \ ( -- modHdl flags exec+locked? ) get: modHdl get: flags addr: exec_cnt w@ nilH put: modHdl ;m :m UNKLUDGE: \ ( modHdl flags exec+locked? -- ) addr: exec_cnt w! put: flags put: modHdl ;m :m GETNAME: \ ( -- addr len ) ^base obj> >name n>count ;m :m EXTNAME: { xaddr xlen \ len -- addr' len' } getName: self -> len pad len cmove xaddr pad len + xlen cmove \ Add extension pad len xlen + ;m :m BINNAME: \ ( -- addr len ) Leaves name of binary file for module. " .BIN" extName: self ;m :m TXTNAME: \ ( -- addr len ) Leaves name of text file for module. " .TXT" extName: self ;m :m LOAD: { \ rc -- } \ Loads if not loaded already nil?: modHdl 0EXIT get: res# IF 'type CODE get: res# getRes dup 0= ?error 138 put: modHdl ELSE binName: self name: fFcb 0 setVref: fFcb openReadOnly: fFcb ?error 138 ['] pause 4+ @ 0 -> pause \ Disable pause over read to avoid \ possible reentrancy size: fFcb dup new: modHdl lock: modHdl \ Maybe we need this ptr: modHdl swap read: fFcb -> rc ['] pause 4+ ! \ Restore pause unlock: modHdl \ Unlock before error check close: fFcb drop rc ?error 141 base: self @ get: dicDateTime u< IF \ BIN file is old version release: modHdl 148 die THEN THEN moveHi: modHdl \ Move module hi since it gets locked clear: exec_cnt ;m :m RELEASE: { \ svModbase -- } clear: exec_cnt \ We certainly hope we know what we're clear: locked? \ doing!! get: modHdl nilH = ?EXIT \ Out if not loaded get: relOffs -1 <> \ Any module-specific action? IF \ Yes lock: modHdl \ We're going to execute in the module modbase -> svModbase ptr: modHdl 32766 + dup -> modbase get: relOffs + execute \ Execute the appropriate word svModbase -> modbase \ No need to unlock since we're \ just about to release THEN get: res# \ Resource? IF get: modHdl trap$ a9a3 \ call ReleaseResource nilH put: modHdl ELSE release: modHdl THEN true -> released? ;m (* KEEP: and DROP: flag this module as needed and not needed, respectively. The main purpose of this flagging is that if GETSPACE is called, loaded modules will be released to make room, unless they have been flagged as needed by KEEP:. But note that RELEASE: ignores the flag, so that we can get rid of a module by force if necessary. This may happen if there was a crash while the module was executing. LOCK: is more drastic than KEEP:, since it means that this module becomes non-relocatable. UNLOCK: reverses a LOCK:. Note that DROP: in effect does an UNLOCK: as well. This "locking" feature is used for ExtrasMod, which has a window, and for the debugger and printMod, which can be entered through the back door (via a vect or a trap). (By the way, we hope we won't have to do this back door business anywhere else. Entering a module through the back door is not usually a very safe thing to do.) Locking a module can give a useful performance improvement if a module is to be called several times in succession, since we bypass the _HLock and _Hunlock calls if the module is marked locked. *) :m KEEP: addr: flags 1 bset ;m :m DROP: get: exec_cnt NIF unlock: modHdl THEN \ Unlock if not executing addr: flags 1 breset clear: locked? ;m :m LOCK: true put: locked? load: self lock: modHdl ;m \ Note: loading does a MoveHi so we don't need to do it again. :m UNLOCK: false put: locked? get: exec_cnt NIF nil?: modHdl NIF unlock: modHdl THEN THEN ;m :m KEEP?: get: exec_cnt 0<> get: locked? or get: flags or ;m :m LOCKED?: get: exec_cnt get: locked? or ;m :m ?RELEASE: keep?: self ?EXIT release: self ;m :m #IMP: get: #imp ;m :m GETIMPORTS: { \ n -- } 0 -> n BEGIN header -92 w, \ Header with handler code for imported word ^base compimp 1 ++> n & } endlist? UNTIL n 1- put: #imp latest name> put: lastimp here put: loadpoint ;m \ =================================== \ Module compilation \ =================================== private :m ExpSupers: { ^nw -- } BEGIN ^nw @ 0EXIT ^nw relocType InThisMod = IF ^nw @abs mfa displace expMethods: [self] THEN 4 ++> ^nw AGAIN ;m public \ This gets called via a late bind, so must be public :m ExpMethods: { maddr -- } BEGIN \ Loop thru methods in this class maddr @ 0>= IF \ We've come to the superclasses maddr expSupers: self EXIT THEN \ Next method maddr 10 + >nxtExp maddr 4+ displace -> maddr AGAIN ;m private mlocal !exports: { \ thisImp thisCfa maddr -- } :m ?!class: \ If this exported item is a class, we set the handler \ code of the imported version and add the method entry offsets \ to the export table. thisCfa 2- w@x -58 = 0EXIT \ Out if it isn't a class -90 thisImp 2- w! thisCfa ffa 1+ 1 bset thisCfa mfa displace expMethods: self ;m :m 1export: next: theMark link> -> thisImp thisImp >name n>count sFind drop -> thisCfa thisCfa thisImp = IF \ Not defined cr thisImp .id 2 spaces 144 die \ "You forgot to define this exported name" false -> cleanMod? ELSE \ All OK. Put info into import definition: thisCfa >name c@ thisImp >name c! \ Name flags pos: $exp thisImp 4+ w! \ Export table index thisCfa >nxtExp \ Add next exp tbl entry ?!class: self \ More stuff if it's a class THEN ;m :mloc !exports: \ { \ n thisImp thisCfa maddr -- } get: #imp 0= ?error 143 \ Module has no exported names clear: $exp get: lastimp set: theMark get: #imp FOR 1export: self NEXT ;mloc (* FixLinks: fixes up the dictionary links within the compiled module. We may want to find words in the module at run time via FIND, but the problem is that dic links are relative, not relocatable. This makes FIND fast, but leads to a problem at run time when the the module is disconnected from the main dictionary. If we didn't do anything, we wouldn't know where to start searching from, and if the search failed, the last link would point into outer space. So what we do is to add a snapshot of CONTEXT to the end of the module to give a place to start from, and to clear the lowest link on each thread to zero (which means the end). *) :m FixLinks: { \ link prevLink -- } #threads FOR context i cells + -> link BEGIN link -> prevLink link displace -> link link modstart u< UNTIL 0 prevLink ! NEXT here 4+ context - , \ Adjustment value for context copy context 32 n, \ Add copy of Context to end of module ;m :m GoodCompile: { \ size -- } here modstart 8 + displ! \ Store export table offs in header all: $exp n, \ Add export table to end fixLinks: self \ fix dic links in module here modstart - -> size \ Size of module size modstart 12 + ! \ Store size in header binName: self name: fFcb \ Set name of binary file create: fFcb ?error 139 'type BIN 'type MOPS set: fFcb \ Type and signature modstart size write: fFcb \ Write out binary module close: fFcb drop IF msg# 140 \ I/O error on writing bin file ELSE curs -curs cr getName: fFcb type ." saved" cr -> curs THEN ;m public :m COMPILE: { \ newModbase -- } compMod ?error 177 \ Error if already compiling a module release: self \ Get rid of old version, if loaded context 32 put: $cxt \ save CONTEXT since we're going \ to do a temporary FORGET DP -> svDP latest -> svLatest ^base -> compMod get: loadpoint (forget) svDP -> DP true -> cleanMod? pushNew: loadFile txtName: self name: topFile here -> modstart modstart 32766 + -> newModbase 16 reserve \ Reserve space for header and offset to exports table. ^base -> this_mod newModbase LdFromMod dateTime modstart ! \ Put source date in bin module header getDirID: topFile modstart 4+ ! \ Also DirID of source file drop: loadfile 0 -> this_mod !exports: self cleanMod? IF goodCompile: self \ Everything's OK. Do final housekeeping THEN unmod \ Also releases $cxt release: $exp ;m \ FIND: works like FIND, but just searches for a word in this module. :m FIND: { s255 \ thrdOffs modCxt cxtOffs -- cfa T | -- s255 F } load: self s255 \ leave on stack for (find) dup c@ 7 and 4* -> thrdOffs \ like what THREAD does nptr: modHdl size: modHdl + 32 - -> modCxt modCxt 4- @ -> cxtOffs modCxt thrdOffs + displace dup NIF \ thread is empty drop false EXIT THEN cxtOffs - ( s255 1st-link ) (find) ;m :m CLASSINIT: -1 put: relOffs dateTime put: dicDateTime ;m ;class : SETRELEASE \ ( addr -- ) setRelease: [ this_mod ] ; : MLD dup load: ** ; ' mld -> modLoad : MOD? \ ( cfa -- cfa b ) objCfa? NIF false EXIT THEN dup >obj >classCfa ['] module = ; : ?DISP { theCfa size -- } \ handler to release selected modules theCfa mod? NIF drop EXIT THEN free size < \ Do we still need space? IF >obj ?release: module ELSE drop THEN ; \ PURGE forcibly releases all modules, no matter what. It is a vector, \ defined in file Base. : (PRG) { theCfa size -- } \ unlock and release theCfa mod? NIF drop EXIT THEN >obj release: module ; : (PURGE) ['] (prg) big# trav ; ' (purge) -> purge : NEEDSPACE \ ( #bytes -- ) release modules until #bytes are available false -> released? freeblk drop ['] ?disp swap trav ; : GS big# needSpace released? ; ' gs -> getSpace : FROM \ ( -- ^mod sec# ) module \ Create module object latest name> >obj dup -> last_mod 28 ; : IMPORT{ \ ( ^mod sec# -- ) 28 ?pairs getImports: ** ; : EXPORTS_CLASS last_mod exports_class: ** ; (* EVAL" ... " performs an EVALUATE on the quoted string, with one important difference to EVALUATE - it temporarily returns the dictionary to the state it was in when the EVAL" was compiled. This ensures that any later redefinitions of words in the quoted string won't be used. This is usually what you want. If you want redefinitions to be used, use EVALUATE. Note - we've put this definition here in the Modules file, since the saving and restoring of the dictionary state is almost identical to what has to be done during module compilation. *) : (EVAL") context 32 put: $evCxt \ save CONTEXT since we're going \ to do a temporary FORGET DP -> evSvDP latest -> evSvLatest fence 0 -> fence \ disable fence check on (forget) since \ we might be in a module located below \ the dic in memory! r> \ caller addr is where we forget to dup (forget) swap -> fence \ restore fence evSvDP -> DP \ restore DP (but context is still forgotten) count 2dup + aligned >r unEval \ restore context etc. evaluate ; : EVAL" postpone (eval") ," \ parse string delimited by " , add to dic ; immediate (* ****** \ Testing: : QQ ." The right QQ!" cr ; from TESTMOD import{ AA BB CC } : QQ ." This is the wrong QQ!!!" ; \ This one shouldn't! compile: testmod : LOOKFOR Mword find: testmod ; ****** *) \ Now that's done, the next thing we need to do is set up our HFS file \ access: from PATHSMOD import{ OWP GETPATHS .PATHS } :f OPEN_WITH_PATHS OWP ;f compile: pathsMod true -> use_paths? " mops.paths" getPaths \ Right, we now have HFS paths, so we can access our source files in \ different folders. from CALL1&LMOD import{ CallFirst CallLast (GET) (C1) (CL) } ' (get) -> get1st&last ' (C1) -> doCall1st ' (CL) -> doCallLast compile: call1&Lmod 0 value CASE_TYPE from CASEMOD import{ case[ ]=> ], range]=> range], default=> ]case select[ ]select } compile: caseMod : SELECT{ postpone select[ ; immediate : }SELECT postpone ]select ; immediate : IS{ postpone ]=> ; immediate : }END postpone [ ; immediate : DEFAULT{ postpone ] postpone default=> postpone drop ; immediate \ from TOOL import{ CALL ASMCALL FCALL GLOBAL $>GLOB KONST $>KONST } from TOOL import{ CALL ASMCALL FCALL GLOBAL $>GLOB } compile: tool from CALLSMOD import{ SYSCALL KONST $>KONST } compile: callsMod from ASMMOD import{ ASM :CODE :MCODE TOCODE } compile: asmmod endload \ More testing stuff: +echo :class HAHA super{ int } callLast print: :m BAtest: 1 2 3 . . . ;m ;class :class SUBHAHA super{ haha } callLast dump: :m BAtest: -9 -8 -7 . . . ;m ;class haha hh subhaha ss : q db batest: hh batest: ss ; endload : QQ ." QQ here. Hello. " ; \ This gets called from testMod variable VB \ compile: testmod2